
set cConnectionParams {1 0 {}}
set cArrowConnectionParams {1 {0 1 2 4} {}}

proc locate {formula x y bbox} {
	puts $formula
	set I [iexpect::Expect #auto -string $formula]
	$I expect fill "(\[+-<>\])(\[0-9\]*\[.\]?\[0-9\]*)" {
		set name [$I get unmatched]
		set number [$I get match 2]
		puts $number
		if [string length $number] {
			switch -- [$I get match 1] "+" {
				set x [expr $x + $number]
			} "-" {
				set x [expr $x - $number]
			} ">" {
				set x [expr [lindex $bbox 0] + $number]
			} "<" {
				set x [expr [lindex $bbox 2] - $number]
			}
		} 
		$I expect fill "^(\[+-<>\])(\[0-9\]*\[.\]?\[0-9\]*)$" {
			set number [$I get match 2]
			puts $number
			if [string length $number] {
				switch -- [$I get match 1] "+" {
					set y [expr $y + $number]
				} "-" {
					set y [expr $y - $number]
				} ">" {
					set y [expr [lindex $bbox 1] + $number]
				} "<" {
					set y [expr [lindex $bbox 3] - $number]
				}
			} 			
		} eof {
			assert {![string length [$I get unmatched]]} {
				Error in description of location $formula.
			} 
		}
	} eof {
		set name $formula
	}
	
	return [list $name $x $y]
}

proc nameAndLocate {locInfo loc} {
	set nrOfParameters [llength $locInfo]
	if {!$nrOfParameters} {return {}}

	set locName [lindex $locInfo 0]
	if {![string length $locName]} {return {}}
	
	set x [expr round([lindex $loc 0])]
	set y [expr round([lindex $loc 1])]

	if {$nrOfParameters >=  2} {
		set dx [lindex $locInfo 1]
		if {[string is double -strict $dx]} {
			set x [expr $x + $dx]
		}
		if {$nrOfParameters >= 3} {
			set dy [lindex $locInfo 2]
			if {[string is double -strict $dy]} {
				set y [expr $y + $dy]
			}
		}
	}

	return [eval list [list $locName [list $x $y]] [lrange $locInfo 3 end]]	
}

proc findAndLocate {pt locations} {
	set nr [lindex $pt 0]
	if {![string is integer -strict $nr]} {return {}}
	incr nr -1
	if {($nr < 0) || ($nr >= [llength $locations])} {return {}}
	set loc [lindex $locations $nr]
	return [lindex [nameAndLocate $pt $loc] 1]
}

proc extractLocationInfo {action locationType locationTypeInfo {parameters {}}} {
	set value [$locationTypeInfo on $action 0]
	if {![llength $parameters]} {
		return [list $value [uplevel 1 set $action$locationType]]
	}
	set index [$locationTypeInfo on ${action}Index -1]
	if {$index >= 0 && $value < 0} {
		incr index $value
		set value 1
	}
	set parameter [lindex $parameters $index]
	return [list $value [uplevel 1 set $action$locationType] $parameter]
}

proc expandActionProc {actionProc action locationShorthandDict} {
	if {[$locationShorthandDict has [string toupper $actionProc]]} {
		return "$action[$locationShorthandDict of [string toupper $actionProc]]"
	}
	assert {[lsearch [$locationShorthandDict get] $actionProc] >= 0} {
		No such location property <$actionProc>. Choose from one of these (long and short versions): [$locationShorthandDict get]
	}
	return "$action$actionProc"
}

proc includeLocations {name parent operator
	locations locationNames locationNumbers colorTracker mapTranslations locationShorthandDict
	mustNumber numberLocations numberColor
	mustName nameLocations nameColor
	mustDraw drawLocations drawProc
	mustPopulate populateLocations populateProc
	mustDefine defineLocations defineProc
	mustInform infoLocations
} {	
	set locationScene {}
	if {[string length $parent]} {
		$parent updateAttributes [list \$NumberOfScenes [expr [$parent getAttribute \$NumberOfScenes] + 1]]
		[[$parent getSequence] of Operators] prependToAct [list "/$operator xd"]
		set locationScene [createScene $name $parent operator $operator]
	}
	if {![llength $locationNumbers]} {
		set selectedLocations $locations
	} else {
		set selectedLocations {}
		foreach number $locationNumbers {
			lappend selectedLocations [lindex $locations [expr $number - 1]]
		}
	}
	foreach locInfo [lrange $locationNames 0 [expr [llength $selectedLocations] - 1]] loc [lrange $selectedLocations 0 [expr [llength $locationNames] - 1]] {
		set located [nameAndLocate $locInfo $loc]
		if {![llength $located]} continue

		if $mustInform {
			$infoLocations set [lindex [string toupper [lindex $located 0]] 0] [lrange $located 1 2]
		}

		if {[$mapTranslations has [lindex $located 0]]} {
			set located [lreplace [$mapTranslations of [lindex $located 0]] 1 0 [lindex $located 1]]
		}

		if {[string length $locationScene]} {
			$locationScene createActor [eval concat [lrange $located 0 1]]
		}
	}
	
	if $mustNumber {
		set numberPlay [createPlay $name $numberLocations]
		$numberPlay setFront [list "[$colorTracker addColor $numberColor] bn"]
		$numberPlay setBack en
		set numberScene	[createScene Numbers $numberPlay format "value value" operator nr]
		foreach loc $locations {
			$numberScene createActor $loc
		}
	}
	
	if $mustName {
		if {[string length $nameColor]} {
			$nameLocations appendToFront [list "{[$colorTracker addColor $nameColor] \$DrawAlias} bind"]
		} else {
			$nameLocations appendToFront [list "{\$DrawNone} bind"]
		}
	} elseif {[string length $nameLocations]} {
		$nameLocations appendToFront [list "{\$DrawNone} bind"]
	}
		
	if $mustDraw {
		$drawLocations appendToFront [list "{[expandActionProc $drawProc \$Draw $locationShorthandDict]} bind"] 
	} elseif {[string length $drawLocations]} {
		$drawLocations appendToFront [list "{\$DrawNone} bind"]
	}
		
	if $mustPopulate {
		$populateLocations appendToFront [list "{[expandActionProc $populateProc \$Draw $locationShorthandDict]} bind"] 
	} elseif {[string length $populateLocations]} {
		$populateLocations appendToFront [list "{\$DrawNone} bind"]
	}
		
	if $mustDefine {
		$defineLocations appendToFront [list "{[expandActionProc $defineProc \$Define $locationShorthandDict]} bind"] 
	} elseif {[string length $defineLocations]} {
		$defineLocations appendToFront [list "{\$DefineNone} bind"]
	}
}

proc matchLocations {name parent operator
		fromLocations fromLocationNames toLocations toLocationNames} {
		
	set locNames {}
	set fromLocs {}
	set toLocs {}
	foreach locInfo [lrange $fromLocationNames 0 [expr [llength $fromLocations] - 1]] loc [lrange $fromLocations 0 [expr [llength $fromLocationNames] - 1]] {
		set located [nameAndLocate $locInfo $loc]
		if {![llength $located]} continue

		lappend locNames [lindex $located 0]
		lappend fromLocs [lindex $located 1]
		lappend toLocs {}		
	}

	foreach locInfo [lrange $toLocationNames 0 [expr [llength $toLocations] - 1]] loc [lrange $toLocations 0 [expr [llength $toLocationNames] - 1]] {
		set located [nameAndLocate $locInfo $loc]
		if {![llength $located]} continue
		
		set locIndex [lsearch $locNames [lindex $located 0]]
		if {$locIndex == -1} continue

		set toLocs [lreplace $toLocs $locIndex $locIndex [lindex $located 1]]
	}

	set locationScene [createScene $name $parent operator $operator format "name value value value value"]
	foreach locName $locNames fromLoc $fromLocs toLoc $toLocs {
		if {![llength $toLoc]} continue
		$locationScene createActor "$locName $fromLoc $toLoc"		
	}
}

proc adaptLocations {locationInfosPtr imagesDict selections mapAlternatives} {
	upvar $locationInfosPtr locationInfos
	# Determine if all missing need to be included, indicated by an empty last element.
	set newLocationInfos {}
	set locations {}
	if {![llength $locationInfos]} {
		set includeAll true
		set searchLocationInfos {}
	} elseif {![llength [lindex $locationInfos end]]} {
		set includeAll true
		set searchLocationInfos [lrange $locationInfos 0 end-1]
	} else {
		set includeAll false
		set searchLocationInfos $locationInfos
	}
	# Match and adapt each location.
	foreach {imageNames imageParameters} $selections {
		foreach imageName $imageNames {
			if {[$imagesDict has $imageName]} {
				set locationArray [$imagesDict of $imageName]
				foreach listName $imageParameters {
					if {[$locationArray has $listName]} {
						set locationImage [$locationArray of $listName]
						if {[$locationImage hasAttribute locations]} {
							set locNames [$locationImage getAttribute locations]
							set locLongNames {}
							if {[$locationImage hasAttribute longNames]} {
								set locLongNames [$locationImage getAttribute longNames]
							}
							foreach loc [$locationImage listLocations] locName $locNames locLongName $locLongNames {
								set idx 0
								set locName [$mapAlternatives on $locName $locName]
								foreach locInfo $searchLocationInfos {
									if {[string equal $locName [lindex $locInfo 0]]} {
										break
									}
									incr idx
								}
								if {$idx < [llength $searchLocationInfos]} {
									lappend locations $loc
									if {[string length $locLongName]} {
										if {[llength $locInfo] < 4} {
											set locInfo [list [lindex $locInfo 0] [lindex $locInfo 1] [lindex $locInfo 2] $locLongName]
										} elseif {![string length [lindex $locInfo 3]]} {
											set locInfo [lreplace $locInfo 3 3 $locLongName]
										}
									}
									lappend newLocationInfos $locInfo
									set searchLocationInfos [lreplace $searchLocationInfos $idx $idx]
								} elseif {$includeAll} {
									lappend locations $loc
									if {[string length $locLongName]} {
										set locInfo [list $locName 0 0 $locLongName] 
									} else {
										set locInfo [list $locName]
									}
									lappend newLocationInfos $locInfo
								}
							}
						} elseif {[llength $locations]} {
							inform "Color $listName is not a location list in image $imageName. Skipped."
						} else {
							return {}
						}
					} elseif {[llength $locations]} {
						inform "Location list $listName not present in image $imageName. Skipped."
					} else {
						return {}
					}
				}
			} elseif {[llength $locations]} {
				inform "Image $imageName unspecified. Skipped."
			} else {
				return {}
			}
		}
	}
	if {![llength $locations]} {
		return {}
	}
	foreach locInfo $searchLocationInfos {
		inform "Location [Story::hexify [lindex $locInfo 0]] not found in INFO list."
	}
	set locationInfos $newLocationInfos
	return $locations
}

proc modifyConnectionPoint {pt} {
	concat "\{[lindex $pt 0]\}#" "\{[lindex $pt 1] \$MapDrawingScale mul\}#"
}

proc tracePath {points {modifyPoint concat} {closed 1}} {
	if {![llength $points]} {return {}}
	set point [lindex $points 0]
	set nrPoints 1
	set shape "[$modifyPoint $point] m"
	set points [lrange $points 1 end]
	if {![llength $points]} {return $shape}
	if {$closed && [Story::isEqual 0 [Story::distance $point [lindex $points end]]]} {
		set points [lrange $points 0 end-1]
		if {![llength $points]} {return $shape}
	}
	foreach nextPoint $points {
		if {![Story::isEqual 0 [Story::distance $point $nextPoint]]} {
			set point $nextPoint
			incr nrPoints
			set shape [concat $shape "[$modifyPoint $point] l"]
		}
	}
	if {$closed && ($nrPoints > 2)} {set shape [concat $shape p]}
	return $shape
}

proc joinArrowParts {parts {modifyPoint concat}} {
	set shapes {}
	set path {}
	foreach part $parts {
		switch [llength $part] 1 {
			set points [lindex $part 0]
			assert {[llength $points] > 1} {
				"Every piece of an arrow part should have at least 2 points, not [llength $points] as in <$parts>."
			}
			if {[llength $points] == 2} {
				if {[llength $path]} {
					lappend shapes [tracePath $path $modifyPoint]
					set path {}
				}
				lappend shapes [tracePath $points $modifyPoint 0]
			} else {
				if {[llength $path]} {
					lappend shapes [tracePath [concat $path $points] $modifyPoint]
					set path {}
				} else {
					set path $points
				}
			}
		} 2 {
			set path [concat [lindex $part 1] $path [lindex $part 0]]
		} default {
			assert 0 {
				An arrow part should have 1 or 2 elements, not [llength $part] as in <$parts>.
			}
		}
	}
	if {[llength $path]} {
		lappend shapes [tracePath $path $modifyPoint]
	}
	return $shapes
}

proc defineShape {shapeName shapeInfo shapePointsDict shapesDict} {
	global cConnectionParams cArrowConnectionParams
	
	set shape {}
	foreach {locationName constructions} $shapeInfo {
		if {![$shapePointsDict has $locationName]} {
			inform "$locationName of shape $shapeName not listed under locations. Shape not created."
			continue
		}
		set locations [$shapePointsDict of $locationName]
		set isPath 0
		set closing 0
		foreach {operation points} $constructions {
			if {![llength $points]} continue
			set operator [lindex $operation 0]
			set params {}
			# Shorthands
			switch $operator l {
				set operator line
			} c {
				set operator curve
			} a {
				set operator arc
			} rect {
				set operator rectangle
			} arrow {
				set operator connection
				set params $cArrowConnectionParams
			} connection {
				set params $cConnectionParams
			}
			# Distinguish figures and path parts
			set isFigure 0
			set nrPoints 2
			switch $operator square {
				set isFigure 1
			} rectangle {
				set isFigure 1
			} circle {
				set isFigure 1
			} ellipse {
				set isFigure 1
			} connection {
				set isFigure 1
			} line {
				set nrPoints 1
			} curve {
				set nrPoints 3
			} arc {
			} oval {
				set nrPoints 3
			} default {
				inform "Unknown shape operator $operator. Choose between line and circle."
				continue
			}
			# Parameters
			set operatorParams [lrange $operation 1 end]
			set shapeParams {}
			if {![llength $params]} {
				if {[llength $operatorParams]} {
					inform "No operator parameters required for operator <$operator>. Parameters <$operatorParams> ignored."
				}
			} else {
				if {[llength $operatorParams] > [llength $params]} {
					inform "Too many operator parameters <$operatorParams> for operator <$operator>; last [expr [llength $operatorParams] - [llength $params]] ignored."
					set operatorParams [lrange $operatorParams 0 [expr [llength $params] - 1]]
				}
				foreach operatorParam $operatorParams param $params {
					if {[string length $operatorParam]} {
						lappend shapeParams $operatorParam
					} else {
						lappend shapeParams $param
					}
				}
			}

			# Figures
			if {$isFigure} {
				if {![llength $shape]} {
					set isPath 0
				} else {
					assert {!$isPath} {
						"Don't mix figure operator $operator with path operators."
					}
				}
				if {[set excess [expr [llength $points] % $nrPoints]]} {
					inform "Figure operator $operator requires a multiple of $nrPoints points. Last $excess skipped."
					set points [lrange $points 0 end-$excess]
				}
				switch $operator square {
					foreach {point1 point2} $points {
						set p1 [findAndLocate $point1 $locations]
						set p2 [findAndLocate $point2 $locations]
						foreach {x1 y1} $p1 {x2 y2} $p2 {
							set pc1 "[Story::dedouble [expr ($x1 + $x2 - $y1 + $y2) / 2.]] [Story::dedouble [expr ($y1 + $y2 + $x1 - $x2) / 2.]]"
							set pc2 "[Story::dedouble [expr ($x1 + $x2 + $y1 - $y2) / 2.]] [Story::dedouble [expr ($y1 + $y2 - $x1 + $x2) / 2.]]"
							lappend shape "$p1 m $pc1 l $p2 l $pc2 l p"
						}
					}
				} rectangle {
					foreach {point1 point2} $points {
						set p1 [findAndLocate $point1 $locations]
						set p2 [findAndLocate $point2 $locations]
						foreach {x1 y1} $p1 {x2 y2} $p2 {
							lappend shape "$p1 m $x1 $y2 l $p2 l $x2 $y1 l p"
						}
					}
				} circle {
					foreach {point1 point2} $points {
						set p1 [findAndLocate $point1 $locations]
						set p2 [findAndLocate $point2 $locations]
						set pm "[Story::dedouble [expr ([lindex $p1 0] + [lindex $p2 0]) / 2.]] [Story::dedouble [expr ([lindex $p1 1] + [lindex $p2 1]) / 2.]]"
						set radius "[expr [Story::distance $p1 $p2] / 2.]"
						lappend shape "[Story::dedouble [expr [lindex $pm 0] + $radius]] [lindex $pm 1] m $pm [Story::dedouble $radius] 0 360 a"
					}
				} ellipse {
					foreach {point1 point2} $points {
						set p1 [findAndLocate $point1 $locations]
						set p2 [findAndLocate $point2 $locations]
						foreach {x1 y1} $p1 {x2 y2} $p2 {
							if {[Story::isEqual $y1 $y2]} {
								inform "Ellipse points <$point1> and <$point2> are on the same horizontal."
								lappend shape "$p1 m [expr 2 * $x2 - $x1] $y1 l p"
								continue
							} elseif {[Story::isEqual $x1 $x2]} {
								inform "Ellipse points <$point1> and <$point2> are on the same vertical."
								lappend shape "$p2 m $x2 [expr 2 * $y1 - $y2] l p"
								continue
							}
							set scale [expr ($y1 - $y2) / double($x2 - $x1)]
							if {[Story::isEqual 1. $scale]} {
								lappend shape "$p1 m $x2 $y1 [expr $y2 - $y1] 0 360 a"
							} elseif {[Story::isEqual -1. $scale]} {
								# Note that y1 and y2 swapped positions compared to the scale 1 situation, 
								# this in order to draw starting from p1.
								lappend shape "$p1 m $x2 $y1 [expr $y1 - $y2] 0 360 a"
							} else {
								set x1 [Story::dedouble [expr $x1 * $scale]]
								set x2 [Story::dedouble [expr $x2 * $scale]]
								lappend shape [concat \
									"[Story::dedouble [expr 1. / $scale] 4] 1 x" \
									"$x1 $y1 m $x2 $y1 [expr $y2 - $y1] 0 360 a" \
									"[Story::dedouble $scale 4] 1 x" \
								]
							}
						}
					}
				} connection {
					foreach {point1 point2} $points {
						set p1 [findAndLocate $point1 $locations]
						set p2 [findAndLocate $point2 $locations]
						set angle [Story::dedouble [Story::angleInDegrees $p1 $p2]]
						set length [Story::dedouble [Story::distance $p1 $p2]]
						foreach {shaftWidth tailings headings} $shapeParams {
							if {![llength $headings]} {set headings $tailings}
							foreach {headExtension headType headWidth headBreadth} $headings {}
							foreach {tailExtension tailType tailWidth tailBreadth} $tailings {}
							foreach pos {head tail} {
								foreach param {Type Width Breadth Extension} {
									if {![string length [set $pos$param]]} {set $pos$param 0}
								}
								if {[Story::isGreater 0 [set ${pos}Breadth]]} {
									set ${pos}Breadth [expr -1 * [set ${pos}Breadth]]
								}
								set ${pos}Length 0
								switch [set ${pos}Type] 1 {
									set ${pos}Length [set ${pos}Breadth]
								} 2 {
									incr ${pos}Extension [expr -[set ${pos}Breadth]]
								}
							}
							
							set extentLength [expr $length + $headExtension + $tailExtension]
							if {[Story::isGreaterOrEqual 0 $extentLength]} continue
							set tailPosition 0
							set headPosition $extentLength
							set shaftLength [expr $extentLength - $headLength - $tailLength]
							# Shorten shaft length
							if {[Story::isGreater 0 $shaftLength]} {
								set shaftLength 0
								set headLength [expr $headLength * $extentLength / ($headLength + $tailLength)]
								set tailLength [expr $tailLength * $extentLength / ($headLength + $tailLength)]
							}
							set baseLength [expr $tailLength + $shaftLength]
							
							set parts {}
							if {![Story::isEqual 0 $tailLength]} {
								if {[Story::isEqual 0 $tailWidth]} {
									lappend parts [list [list "$tailLength 0" "0 0"]]
								} else {
									lappend parts [list [list "$tailLength [expr $tailWidth / 2.]" "0 0" "$tailLength [expr $tailWidth / -2.]"]]
								}
							}
							if {![Story::isEqual 0 $shaftLength]} {
								if {[Story::isEqual 0 $shaftWidth]} {
									lappend parts [list [list "$tailLength 0" "$baseLength 0"]]
								} else {
									lappend parts [list \
										[list "$tailLength [expr $shaftWidth / -2.]" "$baseLength [expr $shaftWidth / -2.]"] \
										[list "$baseLength [expr $shaftWidth / 2.]" "$tailLength [expr $shaftWidth / 2.]"] \
									]
								}
							}
							if {![Story::isEqual 0 $headLength]} {
								if {[Story::isEqual 0 $headWidth]} {
									lappend parts [list [list "$baseLength 0" "$length 0"]]
								} else {
									lappend parts [list [list "$baseLength [expr $headWidth / -2.]" "$length 0" "$baseLength [expr $headWidth / 2.]"]]
								}
							}
							set tfr "$p1 t"
							set rtfr "[expr -1 * [lindex $p1 0]] [expr -1 * [lindex $p1 1]] t"
							if {![Story::isEqual 0 $angle]} {
								set tfr "$tfr $angle o"
								set rtfr "[expr -1 * $angle] o $rtfr"
							}
							if {![Story::isEqual 0 $tailExtension]} {
								set tfr "$tfr [expr -1 * $tailExtension] 0 t"
								set rtfr "$tailExtension 0 t $rtfr"
							}
							lappend shape $tfr
							eval lappend shape [joinArrowParts $parts modifyConnectionPoint]
							foreach pos {head tail} {
								if {[set ${pos}Type] == 2} {
									# Draw an s-shaped wave at the head of the line.
									set position [set ${pos}Position]
									set top [expr [set ${pos}Width] / 2.]
									lappend shape "$position $top m" \
										"[expr $position + $top / -3.] [expr $top * 2 / 3.] [expr $position + $top / -3.] [expr $top / 3.] $position 0 c" \
										"[expr $position + $top / 3.] [expr $top / -3.] [expr $position + $top / 3.] [expr $top * 2 / -3.] $position [expr $top * -1] c"
									if {![Story::isEqual 0 [set ${pos}Breadth]]} {
										if {[Story::isEqual 0 [set ${pos}Position]]} {
											set position [expr -[set ${pos}Breadth]]
										} else {
											set position [expr [set ${pos}Position] + [set ${pos}Breadth]]
										}
										lappend shape "$position [expr $top * -1] l" \
											"[expr $position + $top / 3.] [expr $top * 2 / -3.] [expr $position + $top / 3.] [expr $top / -3.] $position 0 c" \
											"[expr $position + $top / -3.] [expr $top / 3.] [expr $position + $top / -3.] [expr $top * 2 / 3.] $position $top c p"
									}
								}
							}
							lappend shape $rtfr
						}
					}
				} default {
					inform "Figure operator $operator not yet implemented. Skipped."
					continue
				}
				continue
			}
			
			# Path parts
			if {![llength $shape]} {
				set isPath 1
				set startPoint [lindex $points 0]
				set startLocationName $locationName
				set point0 $startPoint
				set shape [list "[findAndLocate $startPoint $locations] m"]
				set points [lrange $points 1 end]
				set endPoint {}
				if {![llength $points]} continue
			} else {
				assert {$isPath} {
					"Don't mix path operator $operator with figure operators."
				}
				if {$closing} {
					lappend shape "[findAndLocate $endPoint $locations] l"
				}
				set point0 $endPoint
			}
			set endPoint [lindex $points end]
			set closing 1
			switch $operator line {
				set points [lrange $points 0 end-1]
			} default {
				set excess [expr [llength $points] % $nrPoints]
				switch $excess 0 {
					set closing 0
				} 1 {
					set points [lrange $points 0 end-1]
				} default {
					inform "Points in excess or missing in path operator $operator in shape $shapeName. Next to last [expr $excess-1] omitted."
					set points [lrange $points 0 end-$excess]
				}
			}
			if {![llength $points]} continue
			switch $operator line {
				foreach point $points {
					lappend shape "[findAndLocate $point $locations] l"
				}
			} curve {
				foreach {point1 point2 point} $points {
					lappend shape "[findAndLocate $point1 $locations] [findAndLocate $point2 $locations] [findAndLocate $point $locations] c"
				}
			} arc {
				set p2 [findAndLocate $point0 $locations]
				foreach {point1 point2} $points {
					set p0 $p2
					set p1 [findAndLocate $point1 $locations]
					set p2 [findAndLocate $point2 $locations]
					set colinear 0
					foreach {x0 y0} $p0 {x1 y1} $p1 {x2 y2} $p2 {
						if {[Story::isEqual $x0 $x1]} {
							if {[Story::isEqual $x1 $x2]} {
								inform "Arc points <$point0>, <$point1> and <$point2> are colinear."
								lappend shape "$p1 l $p2 l"
								set colinear 1
								continue
							} else {
								set q0 $p1; set q1 $p2; set q2 $p0
							}
						} else {
							if {[Story::isEqual $x1 $x2]} {
								set q0 $p2; set q1 $p0; set q2 $p1
							} else {
								set q0 $p0; set q1 $p1; set q2 $p2
							}
						}
					}
					if {$colinear} continue
					foreach {x0 y0} $q0 {x1 y1} $q1 {x2 y2} $q2 {
						set m1 [expr ($y1 - $y0) / double($x1 - $x0)]
						set m2 [expr ($y2 - $y1) / double($x2 - $x1)]
						if {[Story::isEqual $m1 $m2]} {
							inform "Arc points <$point0>, <$point1> and <$point2> are colinear."
							lappend shape "$p1 l $p2 l"
							set colinear 1
							continue
						}
						set xm [expr ($m1 * $m2 * ($y0 - $y2) + $m2 * ($x0 + $x1) - $m1 * ($x1 + $x2)) / (2. * ($m2 - $m1))]
						if {[Story::isEqual $m1 0]} {
							set ym [expr ($y1 + $y2) / 2. - ($xm - ($x1 + $x2) / 2.) / $m2]
						} else {
							set ym [expr ($y0 + $y1) / 2. - ($xm - ($x0 + $x1) / 2.) / $m1]
						}
						set pm [list [Story::dedouble $xm] [Story::dedouble $ym]]
					}
					if {$colinear} continue
					set a0 [Story::dedouble [Story::angleInDegrees $pm $p0]]
					set a1 [Story::dedouble [Story::angleInDegrees $pm $p1]]
					set a2 [Story::dedouble [Story::angleInDegrees $pm $p2]]
					if {$a0 < $a2} {
						if {($a0 < $a1) && ($a1 < $a2)} {set arc a} else {set arc arcn}
					} else {
						if {($a2 < $a1) && ($a1 < $a0)} {set arc arcn} else {set arc a}
					}
					set radius "[Story::dedouble [Story::distance $p1 $pm]]"
					lappend shape "$pm $radius $a0 $a2 $arc"
				}
			} oval {
				set p3 [findAndLocate $point0 $locations]
				foreach {point1 point2 point3} $points {
					set p0 $p3
					set p1 [findAndLocate $point1 $locations]
					set p2 [findAndLocate $point2 $locations]
					set p3 [findAndLocate $point3 $locations]
					foreach {x0 y0} $p0 {x1 y1} $p1 {x2 y2} $p2 {x3 y3} $p3 {
						assert {![Story::isEqual $y1 $y2]} {
							"Ellipse points <$point1> and <$point2> are on the same horizontal."
						} 
						assert {![Story::isEqual $x1 $x2]} {
							"Ellipse points <$point1> and <$point2> are on the same vertical."
						}
						set scale [expr ($y1 - $y2) / double($x2 - $x1)]
						if {[Story::isEqual 1. $scale]} {
							set a0 [Story::dedouble [Story::angleInDegrees "$x2 $y1" $p0]]
							set a3 [Story::dedouble [Story::angleInDegrees "$x2 $y1" $p3]]
							lappend shape "$x2 $y1 [expr abs($y2 - $y1)] $a0 $a3 a"
						} elseif {[Story::isEqual -1. $scale]} {
							set a0 [Story::dedouble [Story::angleInDegrees "$x2 $y1" $p0]]
							set a3 [Story::dedouble [Story::angleInDegrees "$x2 $y1" $p3]]
							lappend shape "$x2 $y1 [expr abs($y2 - $y1)] $a0 $a3 arcn"
						} else {
							set x0 [Story::dedouble [expr $x0 * $scale]]
							set x1 [Story::dedouble [expr $x1 * $scale]]
							set x2 [Story::dedouble [expr $x2 * $scale]]
							set x3 [Story::dedouble [expr $x3 * $scale]]
							set a0 [Story::dedouble [Story::angleInDegrees "$x2 $y1" "$x0 $y0"]]
							set a3 [Story::dedouble [Story::angleInDegrees "$x2 $y1" "$x3 $y3"]]
							lappend shape [concat \
								"[Story::dedouble [expr 1. / $scale] 4] 1 x" \
								"$x2 $y1 [expr abs($y2 - $y1)] $a0 $a3 a" \
								"[Story::dedouble $scale 4] 1 x" \
							]
						}
					}
				}
			} default {
				inform "Path operator $operator not yet implemented. Skipped."
				continue
			}
		}
	}
	if {[llength $shape] && $isPath} {
		if {[string eq $startLocationName $locationName] && [string eq $startPoint $endPoint]} {
			lappend shape p
		} elseif {$closing} {
			lappend shape "[findAndLocate $endPoint $locations] l"
		}
	}
	$shapesDict set $shapeName $shape	
}

proc includeFigure {name parent shapesDict shapes selections fillAct frontAct backAct {execAction ""} {alterGState 0}} {
	set inclusion [createChapter $name $parent]
	set isExecutable [string length $execAction]
	
	if {!$alterGState} {
		$inclusion appendToFront s
		$inclusion appendToBack r
	}
	if {$isExecutable} {
		lprepend fillAct $execAction
	}
	if {[llength $fillAct] == 1} {
		$inclusion appendToFront [list "/fk \{[lindex $fillAct 0]\} bd"]
	} else {
		$inclusion appendToFront [concat [list "/fk \{"] $fillAct [list "\} bd"]]
	}
	$inclusion appendToFront $frontAct

	foreach shapeName $selections {
		if {![$shapesDict has $shapeName]} {
			inform "Shape <$shapeName> for figure <$name> undefined. Skipped."
			continue
		}
		set shapeActName "Shape[capitalize $shapeName]"
		if {$isExecutable} {
			set shapeActName "${shapeActName}Exec"
		}
		if {![[$shapes getSequence] has $shapeActName]} {
			set shapeAct [createChapter $shapeActName $shapes]
			if {$isExecutable} {
				$shapeAct appendToAct "\{"
				$shapeAct appendToAct [$shapesDict of $shapeName]
				$shapeAct appendToAct "\} fk"
			} else {
				$shapeAct appendToAct [$shapesDict of $shapeName]
				$shapeAct appendToAct "fk"
			}
		}
		$inclusion appendToFront [list $shapeActName]
	}
	$inclusion appendToBack $backAct
	
	return $inclusion
}
